home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / DevTools / scred < prev    next >
Encoding:
Text File  |  1992-01-02  |  15.0 KB  |  558 lines
  1. \ SCRED V1.0 ------ JForth SCReen EDitor ------ © 1986 Delta Research
  2. \ V1.0a ----------- fixed the 'TEXT' problem...using the ANSI word.
  3.  
  4. DECIMAL
  5.  
  6. include? gotoxy jf:ansi
  7. include? editor jdev:editor
  8. include? condition jf:condition
  9.  
  10. anew task-scred
  11.  
  12. DECIMAL  
  13. ONLY FORTH DEFINITIONS
  14. ALSO EDITOR DEFINITIONS
  15.  
  16. user INSERT?               user REFRESH-FROM
  17. user WAS-SCR
  18. user 'NOT-CMD-CR           user 'NOT-CMD-QUIT
  19. user 'NOT-SCRED-CR         user 'NOT-SCRED-QUIT
  20. user 'LENGTHS 15 CELLS USER# +!
  21. user MAX-CMD-OUT           user WRAP
  22. user WAS-WRAP              user WAS-INSERT
  23. user WAS-INCLUDED          user WAS-CFBL
  24. user END-ED?               user SE-RP
  25. user DO-REFRESH            user PRE-SCRED-WINDOW
  26.  
  27. : LENGTHS ( line#--adr )  CELLS 'LENGTHS +   ;
  28.  
  29. : SAVED-LINES  ( line#--adr ) C/L * HERE 512 + +  ;
  30.  
  31. : .FILE-NAME ( -- )  scrnamecnt $type  ;
  32.  
  33. ( .CNTRL  prints '^A ' format     )
  34. ( .CHAR prints ' A ' for non-ctl-codes )
  35.  
  36. : .CNTRL ( ctl-code-- )
  37.   $ 5E EMIT  $ 40 + EMIT SPACE  ;
  38.  
  39. : .CHAR  ( not-ctl-code-- ) SPACE EMIT SPACE ;
  40.  
  41. : .RIGHT-BORDER    ( -- ) 
  42.   inverse   68 7      16 0
  43.   DO    2DUP GOTOXY ascii | EMIT  1+
  44.   LOOP  2DROP  plain   ;
  45.  
  46. FORTH DEFINITIONS  $ 1B CONSTANT ESC
  47.  
  48. EDITOR DEFINITIONS
  49.  
  50. $ 0D CONSTANT RET
  51.  
  52. : .KEY-VALUE ( key-value-- )   CONDITION
  53.   DUP ESC = IF     DROP ." ESC"  ELSE
  54.   DUP 0=    IF     DROP ." DEL"  ELSE
  55.   DUP RET = IF     DROP ." CR "  ELSE
  56.   DUP 8 =   IF     DROP ." BAC"  ELSE
  57.   .CNTRL
  58.   ENDCOND   ascii = EMIT ;
  59.  
  60. : NEXT-MENU  ( --- )   OUT @ 61 <
  61.   IF    15 OUT @ OVER MOD - SPACES
  62.   ELSE  77 out @ - spaces  CR
  63.   THEN ;
  64.  
  65. BL ARRAY EDITOR-KEYS
  66. BL ARRAY KEY-ORDER
  67.  
  68. 0 key-order  bl cells  $ ff   fill
  69.  
  70. : >KEYINDEX  ( key -- index , -1 if no room )
  71.   dup $ 7f =
  72.   IF
  73.      drop 0
  74.   THEN
  75.   -1 -1   ( -- key 1stavail foundat )
  76.   \
  77.   \ first, see if we can find it...
  78.   BL 0
  79.   DO
  80.      [ forth ] i  [ editor ] KEY-ORDER @  >r
  81.      r@ ( -- key 1stfree foundat index@ )  3 pick =
  82.      IF
  83.         rdrop  drop  [ forth ] i  [ editor ] leave
  84.      THEN
  85.      ( -- key 1stfree foundat )   r>  2 pick  0<
  86.      IF
  87.         \ no empty one found yet  ( -- key 1stfree foundat index@ )
  88.         -1 =
  89.         IF
  90.            \ this one is free  ( -- key 1stfree foundat )
  91.            nip  [ forth ] i   [ editor ] swap
  92.         THEN
  93.      ELSE
  94.         drop
  95.      THEN
  96.   LOOP
  97.   ( -- key 1stfree foundat )   dup 0<
  98.   IF
  99.      \ it was not found   ( -- key 1stfree -1 )
  100.      drop   dup 0<
  101.      IF
  102.         \ a free cell was not found  ( -- key -1 )
  103.         nip
  104.      ELSE
  105.         \ a free cell was found  ( -- key index )
  106.         tuck   KEY-ORDER !
  107.      THEN
  108.   ELSE
  109.      \ it was found   ( -- key 1stfree index )
  110.      -rot  2drop
  111.   THEN
  112. ;
  113.  
  114. : CHAR>EDITOR-KEYS   ( char -- array-adr )
  115.   >KeyIndex   EDITOR-KEYS
  116. ;
  117.  
  118. : INIT-EDIT-KEYS  ( --- ) ' BEEP ( CFA ) BL 0
  119.     DO    DUP  [ FORTH ] I  [ EDITOR ] EDITOR-KEYS !
  120.     LOOP DROP ;
  121.  INIT-EDIT-KEYS
  122.  
  123. : .INSTRUCTIONS   ( --- )   HELP-LEVEL @ 4 >
  124.    IF      CR inverse   BL 0
  125.         DO   [ FORTH ] I [ EDITOR ] EDITOR-KEYS  @ DUP ' BEEP CFA = NOT
  126.              IF   [ FORTH ] I
  127.                   [ editor ]  KEY-ORDER @ .KEY-VALUE ( CELL+ )
  128.                   NFA ID.  NEXT-MENU
  129.              ELSE DROP
  130.              THEN
  131.         LOOP 77 out @ - spaces plain 
  132.     THEN ;
  133.  
  134. : .CUR ( -- ) R# @ $ 3FF MIN $ 40 /MOD 7 + SWAP 4 + SWAP GOTOXY flushemit ;
  135.  
  136. : !CUR ( cur#-- )   0 MAX $ 3FF MIN R# ! ;
  137.  
  138. : +CUR ( n1-- )  R# @ + !CUR ;
  139.  
  140. : +.CUR ( n1-- )  +CUR .CUR ;
  141.  
  142. : +LIN ( #lines-- )  R# @ $ 40 / + $ 40 * !CUR ;
  143.  
  144. : HOM 0 R# ! .CUR ;
  145.  
  146. : ToBottom  ( -- )
  147.   0 23 gotoxy  ;
  148.  
  149. : <SE-LIST>  ( scr#-- )
  150.   tobottom  BLOCK 0 6 gotoxy  DUP 0 SAVED-LINES 1024 MOVE   16 0
  151.   DO  CR  inverse   [ FORTH ] I 2 .R  SPACE   plain 
  152.       DUP C/L -TRAILING
  153.       DUP I [ editor ] LENGTHS ! TYPE  C/L +
  154.   LOOP DROP   CR    ;
  155.  
  156. : ?SMALL  ( char--char )  noop  ;
  157.  
  158. : .OPTS-HDR  ( -- )
  159.   inverse 
  160.   70 7 GOTOXY ." Insert:"
  161.   70 9 GOTOXY ." Wrap:"
  162.   plain   ;
  163.  
  164. : .ins    ( -- )
  165.   72  8 GOTOXY INSERT? @
  166.   IF   ." Yes"
  167.   ELSE ." No "
  168.   THEN ;
  169.  
  170. : .wrap   ( -- )
  171.   70 10 GOTOXY WRAP @ ?dup
  172.   IF   ." Yes, "  1 .r
  173.   ELSE ."   No   "
  174.   THEN ;
  175.  
  176. : <.opts>  ( -- )
  177.   .ins  .wrap  ;
  178.  
  179. : .OPTIONS   ( -- )
  180.   WAS-INSERT @ INSERT? @ = NOT
  181.   IF   .ins  insert?   @ was-insert ! 
  182.   THEN
  183.   WAS-WRAP   @ WRAP    @ = NOT
  184.   IF   .wrap wrap      @ WAS-WRAP !
  185.   THEN    ;
  186.  
  187. 15 CONSTANT .SCR-X
  188. 40 CONSTANT .FILE-X
  189.  
  190. : .&BLANK ( N1-- ) OUT @ SWAP . OUT @ SWAP - 5 SWAP - SPACES ;
  191.  
  192.  
  193. : .FILE  ( --- ) .FILE-X 6 + 0 GOTOXY .FILE-NAME   ;
  194.  
  195. : SCR&FILE ( -- )  WAS-SCR @ SCR @ = NOT   [ DECIMAL ]
  196.   IF   SCR @ DUP .SCR-X 5  +  0 GOTOXY .&BLANK  WAS-SCR !
  197.   THEN
  198.   ( .FILE? )  .FILE  ;
  199.  
  200. : <TOP>   ( ---)
  201.   inverse 
  202.   .SCR-X   0 GOTOXY ." Scr:"
  203.   .FILE-X  0 GOTOXY ." File:"
  204.   plain
  205.   0        0 GOTOXY .INSTRUCTIONS
  206.    .OPTS-HDR  .RIGHT-BORDER  ;
  207.  
  208. : OPEN-SCRED-WINDOW  ( -- )  pre-scred-window @ 0=
  209.   IF    \ bring up a console window...
  210.   0" RAW:0/2/640/198/SCRED V1.2 -- JForth SCReen EDitor -- © 1992 Delta Research"
  211.         new  (fopen) ?dup
  212.         IF    \ window opened ok...  ( -- pointer )
  213.               CONSOLEOUT @  pre-scred-window !
  214.               CONSOLE!
  215.         ELSE  .err ." can't open window!"  quit
  216.         THEN
  217.   ELSE
  218.         fileword drop
  219.   THEN  ;
  220.  
  221. : CLOSE-SCRED-WINDOW  ( -- )  pre-scred-window @ ?dup
  222.   IF   ( -- orig-pointer )  flushemit
  223.        consoleOUT @ fclose
  224.        pre-scred-window  dup @ console!  off
  225.   THEN ;
  226.   
  227. : INIT-DISPLAY ( SCR#-- )  
  228.   OPEN-SCRED-WINDOW
  229.   CLEARSCREEN <TOP>
  230.   0 OUT !  0 6 GOTOXY <SE-LIST>
  231.   true INSERT? !   -1 was-scr !
  232.   0 WRAP !  0 MAX-CMD-OUT !
  233.   <.OPTS> SCR&FILE .CUR ;
  234.  
  235. : <REFRESH-LINE-AT> ( char# line#-- )  [ FORTH ]   R# @ >R
  236.   DDUP  6 +SHIFT  + R# ! [ editor ]  ( char line--)
  237.   SCR @ BLOCK R# @ + ( C L REF-addr-- )
  238.   C/L 3 PICK -   ( C L addr #left-- )  -TRAILING
  239.   1 PICK 4 PICK - >R   ( C L A #L-- )  ( LINE-ADR R#--R--)
  240.   2 PICK LENGTHS @  4 PICK - MAX  ( C L AD L-- )  dup
  241.   IF   .cur TYPE
  242.   ELSE 2drop
  243.   THEN ( C L -- )   R@ OVER SAVED-LINES C/L MOVE
  244.   ( C L--- )   ( LINE-ADR R#--R--- )
  245.   R> 64 -TRAILING ( C L LIN-ADR LENGTH-- ) SWAP DROP
  246.   SWAP LENGTHS ! DROP  R> R# !   ;
  247.  
  248. : 1ST-DIF-CHAR ( line#--1st-char-dif ) 0 SWAP
  249.   DUP LINE SWAP  SAVED-LINES  ( 0 adr1 adr2-- ) DUP 64 + SWAP
  250.   DO   DUP C@ [ FORTH ] I C@ =  NOT
  251.        IF    LEAVE
  252.        ELSE  BOTH1+
  253.        THEN
  254.   LOOP DROP     ;
  255.  
  256. : ?REF-LINE  ( line#-- )  [ editor ]
  257.   DUP     LINE OVER SAVED-LINES C/L SWAP compare 0=
  258.   IF      DROP
  259.   ELSE    DUP 1ST-DIF-CHAR  SWAP <REFRESH-LINE-AT>
  260.   THEN    ;
  261.  
  262. : ?REFRESH   ( -- )   [ editor ]
  263.   DO-REFRESH @
  264.   IF   16 0
  265.            DO     [ FORTH ] I   [ editor ] ?REF-LINE
  266.            LOOP 0 0 GOTOXY
  267.   THEN ;
  268.  
  269. : SAVE-TO-COMPARE  ( -- )  [ editor ]
  270.   SCR @ WAS-SCR !
  271.   INSERT? @ WAS-INSERT !  WRAP @ WAS-WRAP !      ;
  272.  
  273. : CMD-DONE ( -- ) 'NOT-CMD-CR   @  is CR
  274.                   'NOT-CMD-QUIT @  is QUIT  ;
  275.  
  276. : <SCR-QUIT>  ( 0 SCREDING ! )   CMD-DONE  0 22 GOTOXY
  277.    QUIT  ;
  278.  
  279. : 13EMIT ( -- )  ?PAUSE  OUT @ MAX-CMD-OUT @
  280.      MAX MAX-CMD-OUT ! [ DECIMAL ]  13 EMIT 0 OUT !    ;
  281.  
  282. : NO-LFS  ( -- )
  283.  what's CR  'NOT-CMD-CR !  what's QUIT 'NOT-CMD-QUIT !
  284.  [ ' 13EMIT CFA ] LITERAL      is CR
  285.  [ ' <SCR-QUIT> CFA ] LITERAL  is QUIT   ;
  286.  
  287. FORTH DEFINITIONS
  288. : END-ED ( --- ) [ EDITOR ] SCREDING @ IF  SCREDING OFF   CMD-DONE
  289.  0 22 GOTOXY TRUE   END-ED? !  THEN  ;
  290.  
  291. EDITOR DEFINITIONS
  292.  
  293. : COMMAND-INTERPRET ( --- ) [ FORTH ] [COMPILE] EDITOR  [ editor ]
  294.   0 23 GOTOXY  73 spaces
  295.   NO-LFS SAVE-TO-COMPARE
  296.   13EMIT  ." <SCRED>: "   flushemit
  297.   QUERY 13EMIT  #TIB @ 0
  298.   DO   SPACE
  299.   LOOP 9 SPACES  13EMIT
  300.   0 OUT !  0 MAX-CMD-OUT ! INTERPRET   END-ED? @ NOT
  301.   IF  13EMIT CMD-DONE SCR&FILE .OPTIONS ?REFRESH   .CUR
  302.   THEN  ;
  303.  
  304. : CHECK-FOR   ( cfa  char  -1=left//1=right--- )
  305.   DUP R# +! >R   SCR @ BLOCK R# @ +
  306.   BEGIN ( cfa char curs-adr-- )  ( direction--R-- )
  307.         DUP C@ 2 PICK 4 PICK EXECUTE    ( cfa char cadr fl-- )
  308.         R# @ DUP 0< SWAP 1023 >  OR OR   NOT
  309.   WHILE R@ +   R@ R# +!
  310.   REPEAT R> DDROP DDROP  R# @ 0 MAX  1023 MIN R# !   ;
  311.  
  312. : NEXT-BL-R   ( -- )
  313.   [ ' = CFA ] LITERAL  BL   1 CHECK-FOR   ;
  314.  
  315. : NEXT-BL-L   ( -- )
  316.   [ ' = CFA ] LITERAL  BL  -1 CHECK-FOR   ;
  317.  
  318. : NEXT-BL  NEXT-BL-R ;
  319.  
  320. : BUF/CNT  ( --- ADR CNT )  SCR @ BLOCK  R# @  +  1K R# @ -  ;
  321.  
  322. : >CNT ( ADR CNT --- )  1 K SWAP - R# ! SWAP DROP ;
  323.  
  324. : NEXT-CHAR-R  ( -- )
  325.   [ ' - CFA ] LITERAL  BL   1 CHECK-FOR   ;
  326.  
  327. : NEXT-CHAR-L  ( -- )
  328.   [ ' - CFA ] LITERAL  BL  -1 CHECK-FOR   ;
  329.  
  330. : NEXT-CHAR  NEXT-CHAR-R ;
  331.  
  332. : COLUMN  ( --- )  R# @  NEXT-CHAR  R# @ - ABS DELETE ;
  333.  
  334. : COLUMNS  ( number-of-lines --- )  0
  335. ( works from current cursor position.  removes spaces to align a column )
  336.    DO  COLUMN C/L R# +! LOOP R# @ [ 1K 1- ] LITERAL MIN R# ! ;
  337.  
  338. : REVERSE  ( FROM-LINE TO-LINE --- )   SWAP DDUP -  0
  339.     DO    OVER  D    DUP I 1+
  340.     LOOP  DDROP ;
  341.  
  342. : join   ( ---)  R# @   #LAG R# +! DROP ( NL after reloading )
  343. \ JOIN-LINE  with next line and remove spaces
  344.       NEXT-CHAR R# @ - ABS DELETE ;
  345.  
  346. : WORD-RIGHT  ( -- )  NEXT-CHAR-R NEXT-BL-R
  347.   R# @ 1023 <   IF -1 R# +!   THEN   ;
  348.  
  349. : WORD-LEFT   ( -- )  NEXT-CHAR-L NEXT-BL-L
  350.   R# @ 0=   SCR @ BLOCK C@ BL = NOT   AND
  351.   IF   0    ELSE   1
  352.   THEN +CUR  ;
  353.  
  354. : <?CTL-CHARS>  ( --flag ) ( are their any non-ascii in SCR? )
  355.   SCR @ BLOCK DUP   1K +                 1K   0
  356.   DO     1- DUP  C@  32 126 within? NOT IF LEAVE THEN
  357.   LOOP    -    ;
  358.  
  359. : SCR-UP  ( -- )
  360.   scr @ 1+ sel  SCR&FILE  ;
  361.  
  362. : SCR-DOWN ( -- ) scr @ 0>
  363.   IF   -1 scr +!  SCR&FILE
  364.   ELSE  7 emit
  365.   THEN  ;
  366.  
  367. : CLRLINE ( -- )   R# @ 64 /  [ EDITOR ] E  [ FORTH ] ;
  368.  
  369. : DELINE  ( -- )   R# @ 64 /  [ EDITOR ] D  [ FORTH ] ;
  370.  
  371. : INSLINE ( -- )   R# @ 64 /  [ EDITOR ] S  [ FORTH ] ;
  372.  
  373. EDITOR DEFINITIONS
  374. : DEL-CHAR     ( -- ) [ FORTH ]  R# @ C/L /  (  line-- )  >R
  375.   [ EDITOR ] #LEAD + ( cur-adr-- ) DUP DUP 1+ SWAP ( TO FR TO-- )
  376.   #LAG SWAP DROP 1- (  FROm to cnt-for-this-line --- )
  377.   15 R> -          (  f t c-t-l #lines-left-- )
  378.   WRAP @ MIN       (  f t c-t-l #-to-wrap-- )  C/L * + DUP >R
  379.   MOVE BL SWAP R> + C!  UPDATE   ;
  380.  
  381. : BACKUP-CURSOR  r# @  -1 +cur
  382.   IF  DEL-CHAR
  383.   THEN  ;
  384.  
  385. : <!BLK> ( char--)
  386.  R# @ C/L /MOD >R  1+ ( convert to column# )
  387.   R@ LENGTHS @ MAX R> LENGTHS !   ( update lengths if longer )
  388.   DUP 0 SAVED-LINES R# @ + C!           ( update saved-area )
  389.   R# @ SCR @   ( store in buffer )
  390.   BLOCK + C! UPDATE 1 +CUR ;          ( and advance cursor )
  391.  
  392. : MAKE-A-HOLE  ( -- ) R# @ C/L /MOD  ( char#  line-- )  >R
  393.   SCR @ BLOCK R# @ +  ( char# cursor-addr-- )     DUP 1+
  394.   ROT C/L SWAP - 1-  (  from to cnt-for-this-line --- )
  395.   15 R> -          (  f t c-t-l #lines-left-- )
  396.   WRAP @ MIN       (  f t c-t-l #-to-wrap-- )  C/L * +
  397.   MOVE         ;  ( make a hole!!! )
  398.  
  399. : !BLK  ( char-- )  INSERT? @
  400.   IF    MAKE-A-HOLE THEN  <!BLK>     ;
  401.  
  402. : USE-CHAR  ( char --- )  ?SMALL DUP EMIT !BLK  ;
  403.  
  404. : <SCR-EDIT>  ( -- )
  405.   BEGIN  do-refresh on  (KEY) dup $ 9b =
  406.          IF    drop (KEY)                 CASE
  407.                $ 41 OF   c/l negate +cur  ENDOF
  408.                $ 42 OF   c/l        +cur  ENDOF
  409.                $ 43 OF     1        +cur  ENDOF
  410.                $ 44 OF    -1        +cur  ENDOF  ENDCASE
  411.          ELSE  $ 7f and  DUP  $ 7F = IF DROP 0 THEN  DUP  BL <
  412.                IF    CHAR>EDITOR-KEYS @EXECUTE
  413.                ELSE  USE-CHAR
  414.                THEN  ?REFRESH
  415.          THEN  .CUR
  416.   AGAIN   ;
  417.  
  418. : EDITOR-KEYS?  ( ---)
  419.   BL 0 DO   CR [ FORTH ] I  dup  [ editor ]  KEY-ORDER @ .key-value space
  420.                EDITOR-KEYS @ >NAME ID. LOOP ;
  421.  
  422. : EDITOR-KEY-DOES ( key --- )  ( <function> --in-- )
  423.    DUP $ 7F =
  424.    IF   DROP   0
  425.    THEN
  426.    ( -- key )  >KeyIndex  dup 0<  ?ABORT" EDITOR-KEY-DOES: Invalid key"
  427.    EDITOR-KEYS  []  ' CFA     SWAP !   ;
  428.  
  429. exists? set-rp not
  430. .IF    ascii X   ' rp! >name 1+ c!
  431.        max-inline @  20 max-inline !
  432.        : set-rp  ( rp -- )  rp!   inline ;
  433.        max-inline !
  434.        ascii R   ' Xp! >name 1+ c!
  435. .THEN
  436.  
  437. \ EDITOR-KEY WORDS
  438. HEX
  439. makeucase @  makeucase off  ( MUST STAY IN UPPER CASE TILL RESTORED!!!!! )
  440. : ForthCmd    ( --- )   SE-RP @ SET-RP                   ;
  441. : Down        ( --- )   40 +CUR    DO-REFRESH OFF        ;
  442. : Left        ( --- )   -1 +CUR    DO-REFRESH OFF        ;
  443. : Up          ( --- )   -40 +CUR   DO-REFRESH OFF        ;
  444. : Right       ( --- )   1 +CUR     DO-REFRESH OFF        ;
  445. : InsertFlip  ( --- )   INSERT? @ 0= INSERT? ! .OPTIONS DO-REFRESH OFF ;
  446. : HorizTAB    ( --- )   R# @ 8 / 8 * 8 + !CUR  DO-REFRESH OFF          ;
  447. : Join        ( --- )   JOIN ;
  448. : ClearLine    ( --- )    CLRLINE          ;
  449. : InsertLine   ( --- )    INSLINE          ;
  450. : DeleteLine   ( --- )    DELINE           ;
  451. : DeleteChar   ( --- )    DEL-CHAR         ;
  452. : Column        ( --- )    COLUMN           ;
  453. : WordRight    ( --- )    WORD-RIGHT   DO-REFRESH OFF    ;
  454. : WordLeft     ( --- )    WORD-LEFT    DO-REFRESH OFF    ;
  455. : BackSpace          ( --- )    BACKUP-CURSOR    ;
  456. : NextSCR     ( --- )    SCR-UP           ;
  457. : PrevSCR     ( --- )    SCR-DOWN         ;
  458. : NextLine     ( --- )    1 +LIN       DO-REFRESH OFF    ;
  459. : DeleteWord   ( --- )    -1 +CUR  NEXT-CHAR R# @ NEXT-BL
  460.      R# @ - ABS  DELETE ;
  461. : Exit   ( --- )
  462.   SAVE   [ EDITOR ]  SCREDING OFF
  463.   0 22 GOTOXY    END-ED? ON
  464.   SE-RP @ SET-RP  ;
  465.  
  466.  
  467. CTL E  EDITOR-KEY-DOES  Up
  468. 7F     EDITOR-KEY-DOES  DeleteChar
  469. CTL A  EDITOR-KEY-DOES  WordLeft
  470. CTL M  EDITOR-KEY-DOES  NextLine
  471. CTL I  EDITOR-KEY-DOES  HorizTAB
  472.  
  473. CTL X  EDITOR-KEY-DOES  Down
  474. CTL W  EDITOR-KEY-DOES  DeleteWord
  475. CTL F  EDITOR-KEY-DOES  WordRight
  476. CTL J  EDITOR-KEY-DOES  InsertLine
  477. CTL G  EDITOR-KEY-DOES  Column
  478.  
  479. CTL S  EDITOR-KEY-DOES  Left
  480. CTL K  EDITOR-KEY-DOES  DeleteLine
  481. CTL R  EDITOR-KEY-DOES  PrevSCR
  482. CTL O  EDITOR-KEY-DOES  ClearLine
  483. CTL P  EDITOR-KEY-DOES  Join
  484.  
  485. CTL D  EDITOR-KEY-DOES  Right
  486. CTL H  EDITOR-KEY-DOES  BackSpace
  487. CTL C  EDITOR-KEY-DOES  NextSCR
  488. CTL V  EDITOR-KEY-DOES  InsertFlip
  489. ESC    EDITOR-KEY-DOES  ForthCmd
  490.  
  491. CTL Q  EDITOR-KEY-DOES  Exit
  492. MAKEUCASE !
  493.  
  494. DECIMAL
  495. : HALF-LINES ( #lines-- ) 2/  R# @ >R
  496.   WRAP @ >R    1 WRAP !
  497.   R# @ C/L / DUP >R   C/L * 32 + R# ! R> ( #lines cur-line-- )
  498.   15 OVER - 2/  ( #l cl #max-- )  ROT MIN DUP >R  0
  499.   DO     32 0 DO DEL-CHAR LOOP    128 +CUR
  500.   LOOP   ( cur-line-- )   DROP R> DROP
  501.   R> WRAP !  R> R# !   ;
  502.  
  503. \ ;S   ...following lines will automatically delete remaining
  504. \         1/2 lines.  If used they replace lines 7 - 9 above.
  505. \   LOOP   ( cur-line-- )   1+  R> 0
  506. \   DO  DUP  [ EDITOR ] D [ FORTH ] 1+
  507. \   LOOP   DROP R> WRAP !  R> R# !   ;
  508.  
  509. : END-SCRED    ( -- )
  510.   CLOSE-SCRED-WINDOW
  511.   'not-scred-quit @ is quit
  512.   'not-scred-cr   @ is cr  0sp  ;
  513.  
  514. : <SCRED.QUIT>  ( -- )
  515.   64 23 gotoxy  ." any key QUITs" flushemit key drop
  516.   end-scred   QUIT  ;
  517.  
  518. : START-SCRED  ( -- )
  519.   what's QUIT  'not-scred-quit !
  520.   what's CR    'not-scred-cr   !
  521.   ' <SCRED.QUIT> is QUIT
  522.   ' ToBottom     is CR   ;
  523.  
  524. FORTH DEFINITIONS
  525.  
  526. : SE  ( -- )
  527.   SCR-FILE @
  528.   IF
  529.      decimal [ EDITOR ] SCREDING @ NOT
  530.      IF  SCR @ INIT-DISPLAY  SAVE-TO-COMPARE  END-ED? OFF
  531.          SCREDING ON    also editor  .cur
  532.          START-SCRED
  533.          BEGIN rp@  cell-   se-rp !
  534.             <SCR-EDIT>  END-ED? @  0=
  535.             IF
  536.                COMMAND-INTERPRET
  537.             THEN
  538.             END-ED? @
  539.          UNTIL END-SCRED
  540.      THEN
  541.   ELSE
  542.      >newline 7 emit
  543.      ." SE: there is no open SCR-FILE. Use: SCRED <filename>" quit
  544.   THEN
  545.   SCR-FILE @
  546.   IF
  547.      >newline cr
  548.      ." A Reminder...  the file '" .file-name ." ' is still open."  cr
  549.      ." Don't forget to CLOSE-SCR when you are done with it." cr cr
  550.   THEN
  551. ;
  552.  
  553. : SCRED ( --- ) ( "<filename>" )
  554.   OPEN-SCR  1 SEL  SE  ;
  555.  
  556. ONLY FORTH DEFINITIONS
  557.  
  558.